dnl -*-fortran-*-
C
C     This code is distributed under the terms and conditions of the
C     CCP4 licence agreement as `Part i)' software.  See the conditions
C     in the CCP4 manual for a copyright statement.
C
dnl *** This file is meant to be processed by m4 with an appropriate 
dnl     definition for the system type to produce unix.f.
dnl     Be very careful about changing the m4-isms -- it's particularly easy 
dnl     to introduce spurious spaces.  It would be less fragile with cpp, but
dnl     we can't rely on being able to find it and use it with Fortran.
dnl
dnl     Be careful about declaring system library routines either external or
dnl     intrinsic -- it's probably better to leave them undeclared and let the
dnl     compiler sort it out since this behaviour may (does?) differ.
dnl
dnl $Id: unix.m4,v 1.53 2000/01/17 14:32:12 mdw Exp $
dnl
changequote([,])dnl * use [] as quotes rather than `'
dnl
dnl * units for record lengths:
ifelse(_sgi,1,
  [define(_ubytes,'WORDS')],
dnl Changed in `DEC fortran' as opposed to (old) MIPS compiler on Ultrix:
_dec_fortran,1,
  [define(_ubytes,'WORDS')],
  [define(_ubytes,'BYTES')])dnl
dnl
dnl * fortran compiler may or may not accept READONLY specifier on OPEN.
dnl   specifying it might catch the occasional bug.
ifelse(
_convex,1,
  [define(_readonly,[READONLY,])],
_sgi,1,
  [define(_readonly,[READONLY,])],
dnl * in Dec Fortran V3.0-2, at least, this seems to be *necessary*:
_dec_fortran,1,
  [define(_readonly,[READONLY,])],
  [define(_readonly,)])dnl
dnl
dnl * fortran compiler may or may not accept CARRIAGECONTROL specifier on OPEN:
ifelse(
_convex,1,
  [define(_carriagecontrol,[CARRIAGECONTROL=CCNTRL,])],
_sgi,1,
  [define(_carriagecontrol,[CARRIAGECONTROL=CCNTRL,])],
_concentrix,1,
  [define(_carriagecontrol,[CARRIAGECONTROL=CCNTRL,])],
  [define(_carriagecontrol,)])dnl
dnl
dnl * sometimes we can use IOINIT to specify carriagecontrol:
ifelse(_sun,1,
  [undefine(_has_carriagecontrol)define(_ioinit,1)])dnl
dnl
dnl * In some cases we can't unlink scratch files in case they're rewond
dnl   since REWIND is implemented as close + open.  Maybe a better solution
dnl   would use a routine doing a rewind instead of REWIND on scratch files.
dnl   There does *not* seem to be a problem with the following systems:
dnl     irix (4.0.5) (but see below), osf/1 (1.3), concentrix 2800 (3.0),
dnl     aix (2.3?), HPUX (9.01), SunOS (4.1.3/SunPro 2.0.1)
dnl  I'm inclined to think _cant_unlink should be the default now...
ifelse(_convex,1,
  [define(_cant_unlink,1)],dnl  OS 10, at least
_titan,1,
  [define(_cant_unlink,1)],dnl
_irix51,1,
  [define(_cant_unlink,1)],dnl  necessary in irix 5.1 up
dnl I thought _cant_unlink wasn't necessary for libf2c, but it certainly
dnl seems to be now (Irix5).  I wonder if this is somehow to do
dnl with stdio rather than the fortran library itself...
_f2c,1,
  [define(_cant_unlink,1)],dnl
_g77,1,
  [define(_cant_unlink,1)],dnl
_esv,1,
  [define(_cant_unlink,1)])dnl
dnl * In the case above, we then want to open STATUS='DELETE', if 
dnl   supported.  Note the file will still be left around if the program
dnl   crashes.  Irix (f77 3.4.4) tolerates the unlink but re-instates
dnl   the file when you try to do anything with it...
ifelse(_convex,1,
  [define(_dispose,[DISPOSE=DISP,])],
_sgi,1,
  [define(_dispose,[DISPOSE=DISP,])],
_esv,1,
  [define(_dispose,[DISPOSE=DISP,])],
  [define(_dispose,)])dnl
dnl
C  *** this file was automatically generated by configure
C  *** edit by hand only in extremis
C
C ========
C UNIX.FOR
C ========
C
C CCPOPN - open a file
C UBYTES - Returns number of bytes per word and 'words'/'bytes'
C          to indicate if byte handling is available
C UCPUTM - Get CPU time
C UGERR  - Get error explanation
C UGTENV - Get value of env. variable
C UGTIUD - Get user id - it's name
C UIDATE - Get date in 3 integer format
C UISATT - Is file a terminal?
C USTIME - Get absolute time in seconds (-1 for VMS)
C UTIME  - Get current time
C VAXVMS - Logical function returns TRUE if VAX/VMS
C TTSEND - Write string to terminal with various carriage control
C     options
C GETELAPSED - Print timing info for CCPERR
C UGTARG - Get command-line argument
C GETREF - Abstracted from abscale since it has BYTE declaration.
C CCPSPW - Spawns a new process to run shell command
C
C
      SUBROUTINE CCPOPN(IIUN,LOGNAM,KSTAT,ITYPE,LREC,IFAIL)
C     ====================================================
C
C---- This subroutine is used to open a file
C
C     The requirement to specify that leading carriage control
C     characters in the output records should be obeyed (or not) can't
C     be implemented portably; likewise specifying readonly opening.
C     Some compilers accept VAXtran `carriagecontrol=' and `readonly'
C     specifiers; if so we use them.  Others have IOINIT, which can be
C     used to specify the carriage control.  The HPUX compiler is said
C     not to have any means of doing this and AIX seems to be likewise,
C     sigh; they both seem to obey the normal unix convention of
C     printing the format as-is rather than obeying the first character
C     as carriage control.  Concentrix does obey the first column a la
C     VMS and `traditional' Fortran; the MIPS compilers have a compile
C     (link?) option to do so.  [Unfortunately, carriagecontrol
C     specification isn't even defined in Fortan90, although
C     `ACTION="READ"' can be used.]
C
C PARAMETERS
C ==========
C
C        IIUN (I)   UNIT NUMBER
C      LOGNAM (I)   LOGICAL FILE NAME (UP TO 8 CHARACTERS)
C       KSTAT (I)   FILE STATUS FLAG =1, 'UNKNOWN'
C                                    =2, 'SCRATCH'
C                                    =3, 'OLD'
C                                    =4, 'NEW'
C                                    =5, 'READONLY'
C                                    =6, 'PRINTER'
C       ITYPE (I)   FILE TYPE FLAG =1, 'SEQUENTIAL' 'FORMATTED'
C                                  =2, 'SEQUENTIAL' 'UNFORMATTED'
C                                  =3, 'DIRECT'     'FORMATTED'
C                                  =4, 'DIRECT'     'UNFORMATTED'
C        LREC (I)   RECORD LENGTH FOR DIRECT ACCESS FILE (NO. OF
C                   CHARACTERS FOR A FORMATTED FILE OR WORDS FOR
C                   AN UNFORMATTED FILE). NOT RELEVANT FOR A SEQUENTIAL
C                   FILE
C       IFAIL (I/O) ON INPUT:     =0, STOP ON OPEN FAILURE
C                                 =1, CONTINUE AFTER OPEN FAILURE
C                   ON OUTPUT:    UNCHANGED IF FILE OPEN OK
C                                 =-1, ERROR IN OPENING FILE
C
C     .. Scalar Arguments ..
      INTEGER IFAIL,KSTAT,ITYPE,IIUN,LREC
      CHARACTER LOGNAM* (*)
C     ..
C     .. Local Scalars ..
      INTEGER LLREC,IUN,IBYTES,ISTAT,L
      CHARACTER CCNTRL*7,ST*7,FRM*12,ERRSTR*500,
     +     NAMFIL*255,HANDLE*5,OPNVAR*20, access*10
      INTEGER UNKNWN, SCRTCH, OLD, NEW, RDONLY, PRINTR
      LOGICAL CCPEXS, LNONAM
      PARAMETER (UNKNWN=1, SCRTCH=2, OLD=3, NEW=4, RDONLY=5, PRINTR=6)
ifdef(_ioinit,[      LOGICAL JUNK])dnl
C     ..
C     .. Local Arrays ..
      CHARACTER STAT(6)*7, DISP*6
C     ..
C     .. External Functions ..
      INTEGER LENSTR, LUNSTO
ifdef(_ioinit,[
      LOGICAL IOINIT])dnl
      EXTERNAL LENSTR, LUNSTO
C     ..
C     .. External Subroutines ..
      EXTERNAL UGERR,UGTENV,CCPEXS
C     ..
C     .. Data statements ..
C     NB mustn't have SCRATCH in here, because result is system
C     -dependent
      DATA STAT/'UNKNOWN','UNKNOWN','OLD','NEW','OLD','UNKNOWN'/
C     ..
C     
      ISTAT = KSTAT
C     Negative unit number means don't give messages for successful open
      IUN = IIUN
      IF (IIUN.LT.0) IUN = -IIUN
C     Check args:
      IF (ISTAT.LT.1 .OR. ISTAT.GT.6 .OR. ITYPE.LT.1 .OR. ITYPE.GT.4)
     +     THEN 
        IF (IFAIL.EQ.0) THEN
          CALL CCPERR(1,
     +         '**CCPOPN ERROR** Invalid parameters in call')
        ELSE
          WRITE (LUNSTO(1),
     +         '('' **CCPOPN ERROR** Invalid parameters in call'',/)')
          IFAIL = -1
        END IF
        RETURN
      ENDIF 
C
C     Do nothing for pre-connected units (what's the significance of
C     `TERM...'?) 
      IF (LOGNAM.EQ.'DATA' .OR. LOGNAM.EQ.'PRINTER' .OR.
     $     LOGNAM(:4).EQ.'TERM') RETURN
C
C     if environment variable CCP4_OPEN has value `UNKNOWN', open files
C     with status UNKNOWN rather than new if they exist
      IF (ISTAT.EQ.NEW) THEN
        OPNVAR = ' '
        CALL UGTENV('CCP4_OPEN',OPNVAR)
        IF (OPNVAR.EQ.'UNKNOWN') ISTAT = 1
      END IF
C
C     check for `logical name' referencing real file
      CALL UGTENV(LOGNAM,NAMFIL)
      LNONAM = .FALSE.
      IF (NAMFIL.EQ.' ') THEN
        IF (.NOT. CCPEXS(LOGNAM)) LNONAM = .TRUE.
        NAMFIL = LOGNAM
      END IF
C     VMS null device (VMS code canonicalises /dev/null)
      IF (NAMFIL.EQ.'NL:' .OR. NAMFIL.EQ.'nl:') NAMFIL='/dev/null'
C     Special case:  /dev/null should be opened UNKNOWN
      IF ( NAMFIL.EQ.'/dev/null') ISTAT = 1
C
C     type of open
      ST = STAT(ISTAT)
      IF (ITYPE.EQ.2 .OR. ITYPE.EQ.4) THEN
        FRM = 'UNFORMATTED'
      ELSE
        FRM = 'FORMATTED'
      ENDIF 
      IF (ITYPE .EQ. 1 .OR. ITYPE.EQ.2) THEN
        ACCESS='SEQUENTIAL'
      ELSE
        ACCESS='DIRECT'
      ENDIF
C
      IF (ISTAT.EQ.SCRTCH) THEN
        DISP = 'DELETE'
      ELSE
        DISP = 'KEEP'
      ENDIF
C     
      IF (access.eq.'DIRECT') THEN
C       Need to check is record length in words or bytes and set LLREC
C       accordingly. 
        CALL UBYTES (IBYTES,HANDLE)
        LLREC = LREC*IBYTES
        IF (HANDLE.EQ.'WORDS'.AND.ITYPE.EQ.4) LLREC=LLREC/IBYTES
        IF (ISTAT.EQ.RDONLY) THEN
C         _readonly may be defined as null or as `READONLY,'
          OPEN(UNIT=IUN,STATUS='UNKNOWN',ACCESS='DIRECT',FORM=FRM,
     +         _readonly
     +         FILE=NAMFIL,RECL=LLREC,IOSTAT=IOS,ERR=5)
        ELSE
          OPEN(UNIT=IUN,STATUS='UNKNOWN',ACCESS='DIRECT',FORM=FRM,
     +         _dispose
     +         FILE=NAMFIL,RECL=LLREC,IOSTAT=IOS,ERR=5)
        ENDIF 
      ELSE
C       if available, carriagecontrol='fortran' for print file, else = 
C       'list'.  we can use ioinit instead where it's available (see e.g.
C       Sun manual). 
        IF (ISTAT.EQ.PRINTR) THEN
C         want to obey format characters in column 1
          CCNTRL = 'FORTRAN'
          FRM = 'FORMATTED'
ifdef(_ioinit,
[      JUNK = IOINIT(.TRUE., .FALSE., .FALSE., ' ' , .FALSE.)
])dnl
        ELSE
C         no special significance to column 1
          CCNTRL = 'LIST'
ifdef(_ioinit,
[      JUNK = IOINIT(.FALSE., .FALSE., .FALSE., ' ' , .FALSE.)
])dnl
        END IF
        IF (FRM .EQ. 'UNFORMATTED') THEN
C         (carriage control not relevant)
          IF (ISTAT.EQ.RDONLY) THEN
            OPEN(UNIT=IUN, FILE=NAMFIL, STATUS=ST, ACCESS='SEQUENTIAL',
     +           _readonly
     +           FORM=FRM, ERR=5, IOSTAT=IOS)
          ELSE
            OPEN(UNIT=IUN, FILE=NAMFIL, STATUS=ST, ACCESS='SEQUENTIAL',
     +           _dispose
     +           FORM=FRM, ERR=5, IOSTAT=IOS)
          ENDIF
        ELSE
          IF (ISTAT.EQ.RDONLY) THEN
            OPEN(UNIT=IUN, FILE=NAMFIL, STATUS=ST, ACCESS='SEQUENTIAL',
     +           _readonly
     +           _carriagecontrol
     +           FORM=FRM, ERR=5, IOSTAT=IOS)
          ELSE
            OPEN(UNIT=IUN, FILE=NAMFIL, STATUS=ST, ACCESS='SEQUENTIAL',
     +           _carriagecontrol
     +           _dispose
     +           FORM=FRM, ERR=5, IOSTAT=IOS)
          ENDIF
        ENDIF
      ENDIF
C
C     Scratch files are immediately unlinked from the directory; they
C     become inaccessible only when closed, but don't appear in the
C     directory and the name can be re-used.
C     NB this may break with REWIND if that is implemented as close +
C     reopen, sigh.  See also _dispose above
ifelse(_cant_unlink,1,,[
      IF (ISTAT.EQ.SCRTCH) CALL CUNLINK (NAMFIL)]
)dnl
C
C     Error check
 5    CONTINUE
C     don't report UNKNOWN if actually SCRATCH
      IF (ISTAT.EQ.SCRTCH) ST = 'SCRATCH'
      IF (IOS.NE.0) THEN
        CALL UGERR(IOS,ERRSTR)
        IF (IFAIL.EQ.0) THEN
C         warning if there was no file associated with logical name
          IF (LNONAM) THEN
             ERRSTR = 'CCPOPN Logical name '//LOGNAM
             ERRSTR(LENSTR(ERRSTR)+2:) = 'has no associated file name'
             CALL CCPERR(2,ERRSTR)
          END IF
C         hard failure
          WRITE (LUNSTO (1),FMT=6002) IUN, NAMFIL(1:LENSTR(NAMFIL)),
     +         LOGNAM(1:LENSTR(LOGNAM))
 6002     FORMAT (' Open failed: Unit:',I4,', File: ',A, ' (logical: ',
     +         A, ')')
          ERRSTR = ' Open failed: File: ' // NAMFIL
          CALL CCPERR(-1, ERRSTR)
        else
C         soft failure
          WRITE (lunsto (1),FMT=6004) FRM, ST, IUN, 
     +         LOGNAM(1:LENSTR(LOGNAM)), NAMFIL(1:LENSTR(NAMFIL)),
     +         ERRSTR(1:LENSTR(ERRSTR))
 6004     FORMAT (' **CCPOPN ERROR**  ',A,3X,A,
     +         ' file open failure on unit ',I3,/' Logical name: ',
     +         A,', ','File name: ',A/1X,A/)
          IFAIL = -1
          RETURN            
        ENDIF
      ELSE
        IF (IIUN.LE.0) RETURN 
        WRITE (ERRSTR,FMT=6000) FRM,ST,IUN
        CALL QPRINT (1, ' ')
        CALL QPRINT (1, ERRSTR)
        ERRSTR = 'Logical name: '
        ERRSTR (15:) = LOGNAM
        L = MIN(LENSTR (ERRSTR) + 1, LEN (ERRSTR))
        ERRSTR (L:) = ', Full name: ' // NAMFIL
        CALL QPRINT (1, ERRSTR)
        CALL QPRINT (1, ' ')
 6000 FORMAT (A,3X,A,' file opened on unit ',I3)
      ENDIF 
      END
C
C
C     =====================
      SUBROUTINE GETELAPSED
C     =====================
C
      EXTERNAL LUNSTO, USTIME
      INTEGER LUNSTO
      REAL TARRAY(2), JUNK
      INTEGER ELAPS, START
      LOGICAL INITED
      SAVE START, INITED
      DATA INITED /.FALSE./
C     
      JUNK = ETIME(TARRAY)
      CALL USTIME(ELAPS)
      ELAPS = ELAPS - START
C     don't print anything if it hasn't been initialised (by CCPFYP)
      IF (INITED) WRITE(LUNSTO(1),6000) TARRAY(1), TARRAY(2), 
     +     ELAPS/60, MOD(ELAPS, 60)
 6000 FORMAT(' Times: User: ', F9.1, 's System: ', F6.1, 's Elapsed:',
     +     I5 , ':',I2.2)
C     
      ENTRY INITFYP
      CALL USTIME(START)
      INITED = .TRUE.
C     Machine-dependent startup, e.g. set FPE on SunOS
ifelse(_sun,1,[
C     common FPEs get sigfpe_abort
      i=ieee_handler('set','common',%val(2))
      ])
      END
C
C
C     ==============================
      SUBROUTINE UBYTES(INUM,STRING)
C     ==============================
C
C UBYTES - Return statistics about byte handling
C
C Input:  none
C
C Output:    INUM - number of bytes per word
C            HANDLE - 'WORDS' or 'BYTES'
C            HANDLE - For unformatted files records are usually
C                     counted in 'BYTES', however both VAX and 
C                     SGI swap to 'WORDS' for this file type.
C
C Arguments: INTEGER     INUM
C            CHARACTER*5 HANDLE
C
C Usage:     CALL UBYTES (INUM,HANDLE)
C
C     .. Scalar Arguments ..
      INTEGER INUM
      CHARACTER STRING*5
C     ..
C
C
      INUM = 4
      STRING = _ubytes
C
      END
C
C
C     ======================
      SUBROUTINE UCPUTM(SEC)
C     ======================
C
C     Get CPU time in seconds
C
C     Parameter:
C     REAL SEC (i/o): If sec<=0.0, initialize timer and return current
C                     elapsed cpu time since start of execution, otherwise
C                     return elapsed cpu since timer was initialized.
C                     Time is in seconds.
C
C     .. Scalar Arguments ..
      REAL SEC
C     ..
C     .. Local Scalars ..
      REAL TLAST
C     ..
C     .. Local Arrays ..
      REAL TARRAY(2)
C     ..
C     .. Save statement ..
      SAVE TLAST
C     ..
      IF (SEC.LE.0.0) THEN
        TLAST = ETIME (TARRAY)
        SEC = TLAST
      ELSE
        SEC = ETIME (TARRAY) - TLAST
      ENDIF
      END
C
C
C     ===============================
      SUBROUTINE UGERR(STATUS,ERRSTR)
C     ===============================
C
C UGERR - Get error message string for error number in STATUS
C     (supposedly).  Actually it ignores STATUS and always uses the
C     *last* error that occurred.
C
C Input:     STATUS - Error number (if negative print error message)
C
C Output:    ERRSTR - Error message string
C
C Arguments: INTEGER       STATUS
C            CHARACTER*(*) ERRSTR
C
C Usage:     CALL UGERR(STATUS, ERRSTR)
C
C     .. Scalar Arguments ..
      INTEGER STATUS
      CHARACTER ERRSTR* (*)
C     ..
C     .. Local Scalars ..
      LOGICAL IPRINT
C     ..
C     .. External Subroutines ..
CHENN>
C      INTEGER IERRNO, LUNSTO
C      EXTERNAL IERRNO, LUNSTO
CHENN<
C     ..
      IPRINT = .FALSE.
      IF (STATUS.LT.0) THEN
        IPRINT = .TRUE.
        STATUS = -STATUS
      END IF
C
C---- Get error message from system
C
CHENN>
C      IF (IERRNO().NE.0) THEN
C        CALL GERROR(ERRSTR)
C      ELSE
        ERRSTR = ' '
C      ENDIF
CHENN<
      IF (IPRINT) WRITE (LUNSTO(1),FMT=6000) 'UGERR',ERRSTR
C
 6000 FORMAT (' ',A,': ',A)
      END
C
C     ================================
      SUBROUTINE UGTENV(NAMENV,VALENV)
C     ================================
C
C UGTENV - Get value of env. variable
C
C Input:     NAMENV - Logical Name (trailing blanks are stripped)
C
C Output:    VALENV - Its value
C
C Arguments: CHARACTER*(*) NAMENV, VALENV
C
C Usage:     CALL UGTENV(NAMENV, VALENV)
C
C     .. Scalar Arguments ..
      CHARACTER NAMENV* (*),VALENV* (*)
C     ..
C     .. External Subroutines ..
C     don't declare getenv
      INTEGER LENSTR
      EXTERNAL LENSTR
C     ..
      CALL GETENV(NAMENV(:LENSTR(NAMENV)),VALENV)
C
      END
C
C
C     =========================
      SUBROUTINE UGTUID(USRNAM)
C     =========================
C
C UGTUID - Get user ID
C
C Input:     none
C
C Output:    UID - user ID string
C
C Arguments: CHARACTER*(*) UID
C
C Usage:     CALL UGTUID(UID)
C
C     .. Scalar Arguments ..
      CHARACTER USRNAM* (*)
C     ..
C     .. External Subroutines ..
C     don't declare getenv
C     ..
      CALL GETENV('USER',USRNAM)
      IF (USRNAM.EQ.' ') CALL GETENV('LOGNAME',USRNAM)
C
      END
C
C
C     ====================================
      SUBROUTINE UIDATE(IMONTH,IDAY,IYEAR)
C     ====================================
C
C UIDATE - Get date in 3 integer format. Alliant uses INTEGER*4
C          and order is IDAY,IMONTH,IYEAR
C
C Input:     none
C
C Output:    MONTH,DAY,YEAR
C
C Arguments: INTEGER MONTH, DAY, YEAR
C
C Usage:     CALL UIDATE(MONTH, DAY, YEAR)
C
C     .. Scalar Arguments ..
      INTEGER IDAY,IMONTH,IYEAR
C     .. Local Arrays ..
      INTEGER IARRAY(3)
C     ..
C     don't declare IDATE -- it's often an intrinsic to avoid confusion
C     between the two possible calling sequences.  On SGI, it's only
C     documented in one style but seems to work with the canonical
C     Unix one too; however, the order of the arguments of the
C     documented version (used here) *isn't* the same as for VMS...
C
ifelse(_sgi,1,
[C     Updating 3 array elements separately would be illegal aliasing,
C     of course
      CALL IDATE(IDAY,IMONTH,IYEAR)],dnl VMS-style
_esv,1,
[      CALL IDATE(IDAY,IMONTH,IYEAR)],
[      CALL IDATE (IARRAY)
      IDAY = IARRAY(1)
      IMONTH = IARRAY(2)
      IYEAR = IARRAY(3)])
C
      END
C
C
C     ==============================
      SUBROUTINE UISATT(FLUN,ANSWER)
C     ==============================
C
C UISATT - This function determines whether a program is being
C          run on-line if this information is available.
C
C Input:     FLUN - Fortran Unit Number
C
C Output:    ANS - 1 for on-line, 0 otherwise
C
C Arguments: INTEGER FLUN, ANS
C
C Usage:     CALL UISATT (FLUN,ANS)
C
C     .. Scalar Arguments ..
      INTEGER ANSWER,FLUN
C     ..
dnl there doesn't seem to be an AIX hook to translate between
dnl            fortran units and unix stream numbers
ifelse(_AIX,1,
[      INTEGER IFLUN
      INTEGER ISATTY
      EXTERNAL ISATTY
      ANSWER = 0
      IFLUN = FLUN
      IF (FLUN.EQ.5) THEN
        IFLUN = 0
      ELSE IF (FLUN.EQ.6) THEN
        IFLUN = 1
      ELSE
        CALL CCPERR(1,'Unit number other than 5 or 6 used with'//
     +       'UISATT or ISATTY (AIX restriction)')
      ENDIF
      IF (ISATTY(%VAL(IFLUN)).EQ.1) ANSWER = 1],
_hpux,1,
[      INTEGER ISATTY
      EXTERNAL ISATTY
      ANSWER = 0
      IF (ISATTY(%VAL(FNUM(FLUN))) .EQ.1) ANSWER = 1],
dnl (else)
[      LOGICAL ISATTY
      EXTERNAL ISATTY
      ANSWER = 0
      IF (ISATTY(FLUN)) ANSWER = 1])
C
      END
C
C
C     =======================
      SUBROUTINE USTIME(ISEC)
C     =======================
C
C USTIME - Get absolute time in seconds.
C          Convex uses STIME (), others seem to use TIME ().
C
C Input:     none
C
C Output:    SEC
C
C Arguments: INTEGER SEC
C
C Usage:     CALL USTIME(SEC)
C
      INTEGER ISEC
C
ifelse(_convex,1,
[      INTEGER STIME
      ISEC = STIME()],
_hpux,1,
[ifelse(_hpux9,1,,[ifelse(_hpux10,1,[      isec=time()],[      ISEC = SECNDS(0.0)])])],
[      INTEGER TIME
C
      ISEC = TIME()])
C
      END
C
C
C     =======================
      SUBROUTINE UTIME(CTIME)
C     =======================
C
C UTIME - Get current time hh:mm:ss
C
C Input:     none
C
C Output:    TIME - as ASCII string
C
C Arguments: CHARACTER*(*) CTIME
C
C Usage:     CALL UTIME(CTIME)
C
C     .. Scalar Arguments ..
      CHARACTER CTIME* (*)
C     ..
C     .. Local Arrays ..
      INTEGER IARRAY(3)
C     ..
ifdef(_hpux,
[      CALL TIME(CTIME)],
[      CALL ITIME(IARRAY)
      WRITE (CTIME,FMT=6000) IARRAY(1),IARRAY(2),IARRAY(3)
 6000 FORMAT (I2,2 (':',I2.2))])
      END
C
C
C     =========================
      LOGICAL FUNCTION VAXVMS()
C     =========================
C
C VAXVMS - Operating Sytem in use returns .TRUE. if VAXVMS
C
C Input:     none
C
C Returns:   .TRUE. for VAXVMS, .FALSE. otherwise
C
C Arguments: none
C
C Usage:     VAXVMS ()
C
      VAXVMS = .FALSE.
C
      END
C
C
C     =========================
      LOGICAL FUNCTION WINMVS()
C     =========================
C
C WINMVS - Windows mircrosoft Visual Studio
C
C Input:     none
C
C Returns:   .TRUE. for WINMVS, .FALSE. otherwise
C
C Arguments: none
C
C Usage:     WINMVS ()
C
      WINMVS = .FALSE.
C
      END
C
C
C SUBROUTINE 'TTSEND'
C ===================
C
C Write a string to a terminal with various carriage control options
C [for LAUE]
C
      SUBROUTINE TTSEND (IUN, STR, ICC)
C
C Parameters:
C
C         IUN (I)   Unit number for the output
C         STR (I)   The string to be output
C         ICC (I)   = 0, no carriage control at the end of the string
C                        (for prompts)
C                        e.g. for routine TPROMP
C                   = 1, normal carriage control
C                        e.g. for routine TWRITE
C                   = 2, no carriage control (for sending escape/control
C                        character sequences to ANSI/T4014 terminals)
C                        e.g. for QSCREEN graphics routines
C                   = 3, Output line at current point on screen (no leading
C                        line feed or carriage return - trailing does not
C                        matter)
C
C Machine dependence examples: Convex   1000  FORMAT (A,$)
C                                       1001  FORMAT (A)
C                                       1002  FORMAT (A,$)
C                                       1003  FORMAT (A)
C                              
C                              Vax      1000  FORMAT (' ',A,$)
C                                       1001  FORMAT (' ',A)
C                                       1002  FORMAT ('+',A,$)
C                                       1003  FORMAT ('+',A)
C
C
C====== Specification statements
C
      CHARACTER*(*) STR
      CHARACTER*10 CCNTRL
C
C====== Write string
C
C     'LIST' is the equivalent of the normal unix state
      CCNTRL = 'LIST'
ifelse(_carriagecontrol,[],,
      INQUIRE(IUN,_carriagecontrol)
)dnl
C     in the case of systems obeying the carriagecontrol specifier, 
C     we assume the stream has actually been opened, so that the
C     specifier is suitably defined -- on the Alliant, for instance,
C     it will be 'UNKNOWN' for an unopened stream (6 is pre-opened)
C
      IF (CCNTRL .EQ. 'FORTRAN') THEN
C       VMS-type
        IF (ICC.EQ.0) THEN
          WRITE (IUN,1004) STR
        ELSE IF (ICC.EQ.2) THEN
          WRITE (IUN,1006) STR
        ELSE IF (ICC.EQ.3) THEN
          WRITE (IUN,1007) STR
        ELSE
          WRITE (IUN,1005) STR
        ENDIF
      ELSE
        IF (ICC.EQ.0) THEN
          WRITE (IUN,1000) STR
        ELSE IF (ICC.EQ.2) THEN
          WRITE (IUN,1002) STR
        ELSE IF (ICC.EQ.3) THEN
          WRITE (IUN,1003) STR
        ELSE
          WRITE (IUN,1001) STR
        ENDIF
      ENDIF
C     these formats are mostly non-standard, of course...
1000  FORMAT (A,$)
1001  FORMAT (A)
1002  FORMAT (A,$)
1003  FORMAT (A)
 1004 FORMAT (' ',A,$)
 1005 FORMAT (' ',A)
 1006 FORMAT ('+',A,$)
 1007 FORMAT ('+',A)
      END
C
      SUBROUTINE UGTARG(I, ARG)
      INTEGER I
      CHARACTER *(*) ARG
ifelse(_hpux,1,
[C Maybe HPUX doesn't need to be different here.  The Fortran/9000
C Reference says:
C   4.  GETARG can be accessed only with the
C 
C       $HP9000_800 INTRINSICS  ON
C 
C       compiler directive.  GETARG is similar to IGETARG except that
C       GETARG is called as a subroutine instead of as a function.  It
C       accepts two arguments:  n and str.  n is an integer specifying
C       which command-line argument is requested.  When n=1, it returns
C       the program name (unlike IGETARG which returns the program name
C       when n equals zero).  str is a character variable that will
C       contain the requested command-line argument, padded with blanks on
C       the end.
      INTEGER J
       J = IGETARG(I, ARG, LEN(ARG))],
[      CALL GETARG(I, ARG)])
      END
C     
C     =====================================================
      SUBROUTINE GETREF(KERFLG,NREAD,NSPOTS,DYNAM,MAXOMITL)
C     =====================================================
C
C     [This has been abtracted from ABSCALE because of the BYTE
C     declaration.]
C
C        implicit none
C     
C     
C     
C     
C     
C     Read one reflection into common /IND/, skipping unmeasured reflections
C     Return 1 if end of file or all N spots found
C     Both integrated and profile fitted I's and SD's are stored, one in
C     INTT,SD and the other in INTT2,SD2. The values in INTT,SD are used
C     in scaling, and this is chosen on input card 1 to be either the 
C     integrated or profile fitted value.
C     
C
C This routine is probably VAX specific in its unpacking of indices
C
C
C
C---- IC format generate file variables
C
C
C
C     .. Scalar Arguments ..
      INTEGER           NREAD,NSPOTS,KERFLG,MAXOMITL
      LOGICAL DYNAM
C     ..
C     .. Scalars in Common ..
      INTEGER           IREC,IX,IY,JGUNIT,JH,JK,JL,MND
      LOGICAL           PROFILE
C     ..
C     .. Arrays in Common ..
      REAL              SPACER(12)
      INTEGER           INTT(3),INTT2(3),ISD(3),ISD2(3),JUNK(2)
C     ..
C     .. Local Scalars ..
      INTEGER           I,ICOL,ICOL2,IER,I4INTS,I4INTP
      INTEGER*1              IR,IM
C     ..
C     .. Local Arrays ..
cejd      INTEGER*2         IBUF(18)
      INTEGER*2         IBUF(19)
      INTEGER*1              B(2)
C     ..
C     .. External Subroutines ..
      EXTERNAL          QREAD
C     ..
C     .. Common blocks ..
       LOGICAL BRIEF
       INTEGER IBRIEF
       COMMON /BRF/ BRIEF,IBRIEF
      COMMON      /IND/JH,JK,JL,MND,JUNK,IX,IY,SPACER,INTT,ISD,
     +            INTT2,ISD2
      COMMON      /INREC/JGUNIT,IREC
      COMMON      /INTTYP/PROFILE
C     ..
C     .. Equivalences ..
      EQUIVALENCE       (B(1),IBUF(4)), (B(1),IR), (B(2),IM)
      EQUIVALENCE       (I4INTS,IBUF(7)),(I4INTP,IBUF(13))
C     ..
      SAVE
C
C
          KERFLG = 0
C
C
   10 CONTINUE
      NREAD = NREAD + 1
C
C
      IF (NREAD.GT.NSPOTS) THEN
          GO TO 40
      ELSE
C
C              *************************
          CALL QREAD(JGUNIT,IBUF,36,IER)
C              *************************
C
          IREC = IREC + 1
          IF (IER.NE.0) THEN
              GO TO 30
C
C---- If rejected, skip to next refl
C
CAL ALLOW IR TO HAVE VALUES 5,6
          ELSE IF ((IR.NE.0).AND.(IR.LE.4)) THEN
              GO TO 10
          END IF
      END IF
C
C
      JH = IBUF(1)
      JK = IBUF(2)
      JL = IBUF(3)
      MND = IM
      IF (MND.LT.0) MND = 8
      IX = IBUF(5)
      IY = IBUF(6)
C
C---- A film intensity in ibuf(7) for integrated intensities or
C     ibuf(13) for profile fitted intensities
C
      IF (PROFILE) THEN
          ICOL = 13
          ICOL2 = 7
      ELSE
          ICOL = 7
          ICOL2 = 13
      END IF
C
C
      DO 20 I = 1,3
          IF (DYNAM) THEN
           ISD(I) = IBUF(ICOL+2)
           ISD2(I) = IBUF(ICOL2+2)
           IF (PROFILE) THEN
             INTT(I) = I4INTP
             INTT2(I) = I4INTS
           ELSE
             INTT(I) = I4INTS
             INTT2(I) = I4INTP
           END IF
          ELSE
           INTT(I) = IBUF(ICOL)
           ISD(I) = IBUF(ICOL+1)
           INTT2(I) = IBUF(ICOL2)
           ISD2(I) = IBUF(ICOL2+1)
          END IF
C
C---- Test for badspots (isd=-9999) change to unmeasured
C     this will also reject overloaded reflections
C-AL   Change this so overloads are rejected (and counted) in RDREF
C
       IF ( (ISD(I)   .EQ. -9999) .AND.
     +      (INTT(I)  .NE. MAXOMITL) )       INTT(I) = -9999
       IF ( (ISD2(I)  .EQ. -9999) .AND.
     +      (INTT2(I) .NE. MAXOMITL) ) 
     +                                     INTT2(I) = -9999
C
C
          ICOL = ICOL + 2
          ICOL2 = ICOL2 + 2
   20     CONTINUE
      RETURN
   30 KERFLG = -1
      RETURN 
   40 KERFLG = -1
      RETURN
C
C
      END
C_BEGIN_CCPSPW
      SUBROUTINE CCPSPW(STRING)
C     =========================
C
C     Spawns a new process to run shell command
C
C Arguments:
C ==========
C
C  STRING (I)   CHARACTER*(*): string containing command
C_END_CCPSPW
C
       CHARACTER STRING*(*)
       EXTERNAL SYSTEM
       CALL SYSTEM(STRING)
       END
C
      SUBROUTINE CEXIT (ICODE)
C     trivial interface to system-dependent EXIT routine
      INTEGER ICODE
dnl * for AIX we need an underscore to get the fortran-callable one
dnl   according to an item on the net, but that doesn't work in xlf with
dnl   AIX 2.3.  The EXIT here does seem to be a Fortran one which 
dnl   flushes the o/p buffers.  This may be different in more recent 
dnl   versions where the exit here might end up calling the libc one.
ifelse(_AIX,1,
[      CALL EXIT (%VAL(ICODE))
],
_hpux,1,
[C     The HP-UX fortran manual implies CALL EXIT flushes buffers
C     but it seems not to.  This works in HP-UX A.09.01.
      CALL F77EXIT (ICODE)
],
[      CALL EXIT (ICODE)
])dnl
      END

dnl * f2c needs bit-twiddling stuff (also in library.c)

ifelse(_f2c,1,
[      INTEGER FUNCTION IEOR (I,J)
      INTRINSIC XOR
      IEOR = XOR (I,J)
      END
      INTEGER FUNCTION IOR (I,J)
      INTRINSIC OR
      IOR = OR (I,J)
      END
      INTEGER FUNCTION IAND (I,J)
      INTRINSIC AND
      IAND = AND (I,J)
      END
])
dnl * Dummy GL stubs iff not SGI
ifelse(_sgi,1,,
[        subroutine gdummy
        character *(*) char_dummy
        entry  qreset
          return
        entry  reshap
          return
        entry  qdevic(keybd)
          return
        entry  winope(char_dummy,i0)
          return
        entry  keepas(i1,i2)
          return
        entry  draw2i(i3,i4)
          return
        entry  move2i(i5,i6)
          return
        entry  loadma(i7)
          return
        entry  gconfi
          return
        entry  mmode(i8)
          return
        entry  foregr
          return
        entry  getval(i9)
          return
        entry  color(i10)
          return
        entry  getsiz(r1,r2)
          return
cc        entry  clear this is in somewhere else in -ltermcap
cc          return
        entry  ortho2(r3,r4,r5,r6)
          return
        entry  getori(r7,r8)
          return
        end
        subroutine clear
        end
])dnl

C
CA dummy function for unix
C     =========================
       CHARACTER FUNCTION RTNBKS()
C     =========================
C
C RTNBKS - Returns a Backslash for nt as unix compilers are fussy!
C
C Input:     none
C
C Returns:   \ if WIN32 or not if unix or vms
C
C Arguments: none
C
C Usage:     RTNBKS ()
C
      RTNBKS=' '
C
      END

c     ============================
      subroutine hciftime(ciftime)
c     ============================
ccFrom GERARD@XRAY.BMC.UU.SE Thu Sep 24 00:25:25 1998
c
      implicit none
c
      character ciftime*(*)
c
      integer gmt_hour,gmt_minutes,localdaymonth,
     +        localhours,localminutes,localmonth,localseconds,
     +        localyear,nhours,nminutes,stime,diff
c
      character gmt_diff*1
c
      integer gmtarray(9),tarray(9)
      integer time
c
      intrinsic abs
c
code ...
c
c ... check if the argument can hold 25 characters
c     (better to return an error flag, of course ;-)
c
dnl * len is quoted since also m4 macro 
      if ([len](ciftime) .lt. 25) then
        print *,'error --- hciftime: string too short'
        ciftime = ' '
        return
      end if
c
      stime = time()
      call gmtime(stime,gmtarray)
      call ltime(stime,tarray)
c
      nminutes = gmtarray(2)
      nhours = gmtarray(3)
      localseconds = tarray(1)
      localminutes = tarray(2)
      localhours = tarray(3)
      localdaymonth = tarray(4)
      localmonth = tarray(5) + 1
c .. tarray(6) should be years since 1900 so is Y2K-compliant
      localyear = tarray(6) + 1900
c
c ... calculate time difference in minutes (some time zones
c     differ by N hours + 30 minutes from gmt)
c
      diff = (60*localhours + localminutes) -
     +       (60*nhours + nminutes)
c
c ... allow for different dates to avoid Kim's midnight bug
c     (fudge by simply checking if the day of the month is
c     identical or not; should be okay)
c
      if (diff .lt. 0 .and. tarray(4) .ne. gmtarray(4)) then
        diff = diff + 24*60
      else if (diff .gt. 0 .and. tarray(4) .ne. gmtarray(4)) then
        diff = diff - 24*60
      end if
c
c ... get hour differences by taking INT(minutes)/60
c     since INT(-1.5) would be -2, use ABS and adjust sign
c
      gmt_hour = abs(diff) / 60
      if (diff .lt. 0) gmt_hour = - gmt_hour
      gmt_minutes = diff - 60*gmt_hour
      if (gmt_hour .lt. 0 .or. gmt_minutes .lt. 0) then
        gmt_diff = '-'
      else
        gmt_diff = '+'
      end if
c
      write (ciftime,fmt=6000) localyear,localmonth,localdaymonth,
     +  localhours,localminutes,localseconds,gmt_diff,abs(gmt_hour),
     +  abs(gmt_minutes)
c
c ... NOTE: "i4" in the following format makes that this routine
c           is not Year-10,000-compliant !!!
c
 6000 FORMAT (i4,'-',i2.2,'-',i2.2,'T',i2.2,':',i2.2,':',i2.2,a1,i2.2,
     +       ':',i2.2)
c
      return
      end

C
